home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 6 / adb / s-valuns < prev    next >
Text File  |  1996-02-12  |  9KB  |  261 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                       S Y S T E M . V A L _ U N S                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.9 $                              --
  10. --                                                                          --
  11. --   Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc.  --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with System.Unsigned_Types; use System.Unsigned_Types;
  37. with System.Val_Util;       use System.Val_Util;
  38.  
  39. package body System.Val_Uns is
  40.  
  41.    -------------------
  42.    -- Scan_Unsigned --
  43.    -------------------
  44.  
  45.    function Scan_Unsigned
  46.      (Str  : String;
  47.       Ptr  : access Positive'Base;
  48.       Max  : Positive'Base)
  49.       return Unsigned
  50.    is
  51.       P : Positive'Base;
  52.       --  Local copy of the pointer
  53.  
  54.       Uval : Unsigned;
  55.       --  Accumulated unsigned integer result (in the loop to scan out based
  56.       --  numbers, this is the value of the base, scanned on entry)
  57.  
  58.       Bval : Unsigned;
  59.       --  Value of based number accumulated
  60.  
  61.       New_Val : Unsigned;
  62.       --  Used in checking overflow during accumulation of result
  63.  
  64.       Expon : Integer;
  65.       --  Exponent value
  66.  
  67.       Minus : Boolean := False;
  68.       --  Set to True if minus sign is present, otherwise to False. Note that
  69.       --  a minus sign is permissible for the singular case of -0, and in any
  70.       --  case the pointer is left pointing past a negative integer literal.
  71.  
  72.       Overflow : Boolean := False;
  73.       --  Set True if overflow is detected at any point
  74.  
  75.       Start : Positive;
  76.       --  Save location of first non-blank character
  77.  
  78.       Base_Char : Character;
  79.       --  Base character (# or :) in based case
  80.  
  81.       Base : Unsigned := 10;
  82.       --  Base value (reset in based case)
  83.  
  84.       Digit : Unsigned;
  85.       --  Digit value (0..15) in based case
  86.  
  87.    begin
  88.       Scan_Sign (Str, Ptr, Max, Minus, Start);
  89.  
  90.       if Str (Ptr.all) not in '0' .. '9' then
  91.          Ptr.all := Start;
  92.          raise Constraint_Error;
  93.       end if;
  94.  
  95.       P := Ptr.all;
  96.       Uval := Character'Pos (Str (P)) - Character'Pos ('0');
  97.       P := P + 1;
  98.  
  99.       --  Loop to scan out digits of what is either the number or the base
  100.  
  101.       loop
  102.          exit when P > Max;
  103.  
  104.          --  Non-digit encountered
  105.  
  106.          if Str (P) not in '0' .. '9' then
  107.             if Str (P) = '_' then
  108.                Scan_Underscore (Str, P, Ptr, Max, False);
  109.             else
  110.                exit;
  111.             end if;
  112.  
  113.          --  Accumulate result unless we have overflow. Overflow is detected
  114.          --  by the wrap around, which results in the a smaller value.
  115.  
  116.          else
  117.             New_Val :=
  118.               10 * Uval + Character'Pos (Str (P)) - Character'Pos ('0');
  119.  
  120.             if New_Val < Uval then
  121.                Overflow := True;
  122.             else
  123.                Uval := New_Val;
  124.             end if;
  125.  
  126.             P := P + 1;
  127.          end if;
  128.       end loop;
  129.  
  130.       Ptr.all := P;
  131.  
  132.       --  Deal with based case
  133.  
  134.       if P < Max and then (Str (P) = ':' or else Str (P) = '#') then
  135.          Base_Char := Str (P);
  136.          P := P + 1;
  137.          Bval := 0;
  138.  
  139.          --  Check base value. Overflow is set True if we find a bad base, or
  140.          --  a digit that is out of range of the base. That way, we scan out
  141.          --  the numeral that is still syntactically correct, though illegal.
  142.  
  143.          if Uval not in 2 .. 16 then
  144.             Overflow := True;
  145.          end if;
  146.  
  147.          --  Loop to scan out based integer value
  148.  
  149.          loop
  150.             --  We require a digit at this stage. If we don't have one, then
  151.             --  it isn't a based number after all, so the number we scanned
  152.             --  out as the base (still in Uval) is the value we wnat.
  153.  
  154.             if Str (P) in '0' .. '9' then
  155.                Digit := Character'Pos (Str (P)) - Character'Pos ('0');
  156.  
  157.             elsif Str (P) in 'A' .. 'F' then
  158.                Digit := Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
  159.  
  160.             elsif Str (P) in 'a' .. 'f' then
  161.                Digit := Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
  162.             else
  163.                exit;
  164.             end if;
  165.  
  166.             --  Here we accumulate the value, checking overflow (which
  167.             --  is detected by wrap around leaving the result smaller)
  168.  
  169.             if Digit >= Uval then
  170.                Overflow := True;
  171.             else
  172.                New_Val := Bval * Uval + Digit;
  173.  
  174.                if New_Val < Bval then
  175.                   Overflow := True;
  176.                else
  177.                   Bval := New_Val;
  178.                end if;
  179.             end if;
  180.  
  181.             --  If at end of string with no base char, not a based number
  182.             --  but we signal Constraint_Error and set the pointer past
  183.             --  the end of the field, since this is what the ACVC tests
  184.             --  seem to require, see CE3704N, line 204.
  185.  
  186.             P := P + 1;
  187.  
  188.             if P > Max then
  189.                Ptr.all := P;
  190.                raise Constraint_Error;
  191.             end if;
  192.  
  193.             --  If terminating base character, we are done with loop
  194.  
  195.             if Str (P) = Base_Char then
  196.                Ptr.all := P + 1;
  197.                Base := Uval;
  198.                Uval := Bval;
  199.                exit;
  200.  
  201.             --  Deal with underscore
  202.  
  203.             elsif Str (P) = '_' then
  204.                Scan_Underscore (Str, P, Ptr, Max, True);
  205.             end if;
  206.  
  207.          end loop;
  208.       end if;
  209.  
  210.       --  Come here with scanned unsigned value in Uval. The only remaining
  211.       --  required step is to deal with exponent if one is present.
  212.  
  213.       Expon := Scan_Exponent (Str, Ptr, Max);
  214.  
  215.       if Expon /= 0 and then Uval /= 0 then
  216.  
  217.          --  For non-zero value, scale by exponent value. No need to do this
  218.          --  efficiently, since use of exponent in integer literals is rare,
  219.          --  and in any case the exponent cannot be very large.
  220.  
  221.          loop
  222.             New_Val := Uval * Base;
  223.  
  224.             if New_Val < Uval then
  225.                Overflow := True;
  226.             else
  227.                Uval := New_Val;
  228.             end if;
  229.  
  230.             Expon := Expon - 1;
  231.             exit when Expon = 0;
  232.          end loop;
  233.       end if;
  234.  
  235.       --  Return result, dealing with sign and overflow
  236.  
  237.       if Overflow or else (Minus and then Uval /= 0) then
  238.          raise Constraint_Error;
  239.       else
  240.          return Uval;
  241.       end if;
  242.  
  243.    end Scan_Unsigned;
  244.  
  245.    --------------------
  246.    -- Value_Unsigned --
  247.    --------------------
  248.  
  249.    function Value_Unsigned (Str : String) return Unsigned is
  250.       V : Unsigned;
  251.       P : aliased Positive'Base := Str'First;
  252.  
  253.    begin
  254.       V := Scan_Unsigned (Str, P'Access, Str'Last);
  255.       Scan_Trailing_Blanks (Str, P);
  256.       return V;
  257.  
  258.    end Value_Unsigned;
  259.  
  260. end System.Val_Uns;
  261.